home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / yerk / mps231ss.hqx / Mops ƒ / Modules < prev    next >
Text File  |  1993-02-20  |  11KB  |  428 lines
  1. \ This file implements relocatable modules.  In installed applications,
  2. \ these become separate code segments.
  3.  
  4. true    value    CLEANMOD?
  5. false    value    RELEASED?
  6.     0    value    THIS_MOD
  7.     0    value    LAST_MOD
  8.     0    value    SVDP
  9.     0    value    SVLATEST
  10.     0    value    MODSTART
  11.  
  12.     string    $EXP
  13.     string    $CXT
  14.  
  15. \ variable    SAVE_CONTEXT    8 4 *  allot
  16.  
  17. : UNMOD        \ Puts things back to normal after a module
  18.             \ or stand-alone code compilation
  19.     svDP  0EXIT        \ Out if we're not compiling a module/SA
  20.     svLatest -> latest
  21.     svDP -> DP  0 -> svDP  0 -> compMod
  22.     nil?: $cxt  NIF  ptr: $cxt  context  32  cmove  release: $cxt  THEN
  23.     false -> SAcomp?  ;
  24.  
  25. : >NXTEXP    \ ( n -- )
  26.     modstart -  pad !  pad 4  add: $exp  ;
  27.  
  28.  
  29. :class    MODULE    super{ object }
  30.  
  31.     handle    MODHDL
  32.     byte    EXEC_CNT        \ Must be at an even offset since we sometimes
  33.     bool    LOCKED?        \  do a combined access to exec_cnt and locked?
  34.     byte    FLAGS
  35.     int        RES#
  36.     int        #IMP
  37.     dicaddr    LASTIMP
  38.     dicaddr    LOADPOINT
  39.     var        DicDateTime
  40.     int        RELOFFS
  41.     int        INSTALL?
  42.  
  43. :m BASE:
  44.     nil?: modHdl  IF  0  EXIT  THEN
  45.     nptr: modHdl  ;m
  46.  
  47. :m HANDLE:    get: modHdl  ;m
  48.  
  49. :m .ID:        ^base obj>  .id  ;m
  50.  
  51. :m SETRELEASE:    \ ( addr -- )
  52.     modbase -  put: relOffs  ;m
  53.  
  54. :m SETRESID:    \ ( resID -- )
  55.     put: res#  ;m
  56.  
  57. :m INSTALL?:    get: install?  ;m
  58. :m SETINSTALL:    put: install?  ;m
  59.  
  60. \ :m EXPORTS_CLASS:    addr: flags  2 bset  ;m
  61.  
  62.  
  63. \ KLUDGE: and UNKLUDGE: may be used when we save a dic image, to mark
  64. \ a module as unloaded in the saved image without really unloading it.
  65.  
  66. :m KLUDGE:    \ ( -- modHdl flags exec+locked? )
  67.     get: modHdl  get: flags  addr: exec_cnt  w@  nilH  put: modHdl  ;m
  68.  
  69. :m UNKLUDGE:    \ ( modHdl flags exec+locked? -- )
  70.     addr: exec_cnt  w!  put: flags  put: modHdl  ;m
  71.  
  72. :m GETNAME:    \ ( -- addr len )
  73.     ^base  obj> >name n>count  ;m
  74.  
  75. :m EXTNAME:  { xaddr xlen \ len -- addr' len' }
  76.     getName: self  -> len   pad len cmove
  77.     xaddr  pad len +  xlen  cmove        \ Add extension
  78.     pad  len xlen +  ;m
  79.  
  80. :m BINNAME:    \ ( -- addr len )  Leaves name of binary file for module.
  81.     " .BIN" extName: self  ;m
  82.  
  83. :m TXTNAME:    \ ( -- addr len )  Leaves name of text file for module.
  84.     " .TXT" extName: self  ;m
  85.  
  86.  
  87. :m LOAD:  { \ rc -- }        \ Loads if not loaded already
  88.     nil?: modHdl  0EXIT
  89.     get: res#
  90.     IF
  91.         'type CODE  get: res#  getRes  dup 0= ?error 138
  92.         put: modHdl
  93.     ELSE
  94.         binName: self  name: fFcb  0 setVref: fFcb
  95.         openReadOnly: fFcb  ?error 138
  96.         ['] pause 4+ @  0 -> pause        \ Disable pause over read to avoid
  97.                                         \  possible reentrancy
  98.         size: fFcb  dup  new: modHdl
  99.         lock: modHdl                    \ Maybe we need this
  100.         ptr: modHdl  swap  read: fFcb  -> rc
  101.         ['] pause 4+ !                    \ Restore pause
  102.         unlock: modHdl                    \ Unlock before error check
  103.         close: fFcb  drop  rc ?error 141
  104.         base: self @  get: dicDateTime  u<
  105.         IF                                \ BIN file is old version
  106.             release: modHdl  148 die
  107.         THEN
  108.     THEN
  109.     moveHi: modHdl                        \ Move module hi since it gets locked
  110.     clear: exec_cnt  ;m
  111.  
  112. :m RELEASE:  { \ svModbase -- }
  113.     clear: exec_cnt                    \ We certainly hope we know what we're
  114.     clear: locked?                    \  doing!!
  115.     get: modHdl  nilH =  ?EXIT        \ Out if not loaded
  116.     get: relOffs  -1 <>                \ Any module-specific action?
  117.     IF                                \ Yes
  118.         lock: modHdl                \ We're going to execute in the module
  119.         modbase -> svModbase
  120.         ptr: modHdl  32766 +  dup  -> modbase
  121.         get: relOffs +
  122.         execute                        \ Execute the appropriate word
  123.         svModbase -> modbase        \ No need to unlock since we're
  124.                                     \  just about to release
  125.     THEN
  126.     get: res#                          \ Resource?
  127.     IF
  128.         get: modHdl  trap$ a9a3        \ call ReleaseResource
  129.         nilH put: modHdl
  130.     ELSE
  131.         release: modHdl
  132.     THEN
  133.     true -> released?  ;m
  134.  
  135. \ KEEP: and DROP: flag this module as needed and not needed, respectively.
  136. \ The main purpose of this flagging is that if GETSPACE is called, loaded
  137. \ modules will be released to make room, unless they have been flagged as
  138. \ needed by KEEP:.  But note that RELEASE: ignores the flag, so that we
  139. \ can get rid of a module by force if necessary.  This may happen if there
  140. \ was a crash while the module was executing.
  141.  
  142. \ LOCK: is more drastic than KEEP:, since it means that this module becomes
  143. \ non-relocatable.  UNLOCK: reverses a LOCK:.  Note that DROP: in effect does
  144. \ an UNLOCK: as well.
  145.  
  146. \ This "locking" feature is used for ExtrasMod, which has a window, and
  147. \ for the debugger and printMod, which can be entered through the back
  148. \ door (via a vect or a trap).  (By the way, we hope we won't have to do this
  149. \ back door business anywhere else.  Entering a module through the back door
  150. \ is not usually a very safe thing to do.)  Locking a module can give
  151. \ a useful performance improvement if a module is to be called several times
  152. \ in succession, since we bypass the _HLock and _Hunlock calls if the module
  153. \ is marked locked.
  154.  
  155. :m KEEP:
  156.     addr: flags 1 bset  ;m
  157.  
  158. :m DROP:
  159.     get: exec_cnt NIF  unlock: modHdl  THEN  \ Unlock if not executing
  160.     addr: flags 1 breset  clear: locked?  ;m
  161.  
  162. :m LOCK:
  163.     true  put: locked?  load: self  lock: modHdl  ;m
  164.         \ Note: loading does a MoveHi so we don't need to do it again.
  165.  
  166. :m UNLOCK:
  167.     false  put: locked?
  168.     get: exec_cnt NIF  nil?: modHdl NIF  unlock: modHdl  THEN THEN  ;m
  169.  
  170. :m KEEP?:
  171.     get: exec_cnt  0<>  get: flags  or  ;m
  172.  
  173. :m LOCKED?:
  174.     get: exec_cnt  get: locked?  or  ;m
  175.  
  176.  
  177. :m ?RELEASE:
  178.     keep?: self  ?EXIT
  179.     release: self  ;m
  180.  
  181. :m #IMP:    get: #imp  ;m
  182.  
  183. :m GETIMPORTS:  { \ n -- }
  184.     0 -> n
  185.     BEGIN
  186.         header  -92 w,        \ Header with handler code for imported word
  187.         ^base compimp  1 ++> n
  188.         & }  endlist?
  189.     UNTIL
  190.     n 1-  put: #imp
  191.     latest  name>  put: lastimp
  192.     here  put: loadpoint  ;m
  193.  
  194. \        ====================================
  195.  
  196. private        \ These methods are used only by compile:
  197.  
  198. \        ====================================
  199.  
  200. :m ExpSupers:  { ^nw -- }
  201.     BEGIN
  202.         ^nw @ 0EXIT
  203.         ^nw relocType  InThisMod =
  204.         IF  ^nw @abs mfa displace  expMethods: [self]  THEN
  205.         4 ++> ^nw
  206.     AGAIN  ;m
  207.  
  208. public
  209.                 \ This gets called via a late bind, so must be public
  210. :m ExpMethods:  { maddr -- }
  211.     BEGIN                \ Loop thru methods in this class
  212.         maddr @ 0>=
  213.         IF            \ We've come to the superclasses
  214.             maddr  expSupers: self  EXIT
  215.         THEN
  216.                     \ Next method
  217.         maddr 10 +  >nxtExp
  218.         maddr 4+ displace  -> maddr
  219.     AGAIN  ;m
  220.  
  221. private
  222.  
  223. mlocal !EXPORTS: { \ thisImp thisCfa maddr -- }
  224.  
  225. :m ?!CLASS:    \ If this exported item is a class, we set the handler
  226.             \ code of the imported version and add the method entry offsets
  227.             \ to the export table.
  228.  
  229.     thisCfa 2- w@x -58 =  0EXIT        \ Out if it isn't a class
  230.     -90  thisImp 2- w!
  231.     thisCfa ffa 1+ 1 bset
  232.     thisCfa mfa  displace  expMethods: self  ;m
  233.  
  234.  
  235. :m 1EXPORT:
  236.     next: theMark  link> -> thisImp
  237.     thisImp  >name n>count  sFind
  238.     drop -> thisCfa
  239.     thisCfa thisImp =
  240.     IF                                    \ Not defined
  241.         cr thisImp .id  2 spaces  msg# 144
  242.         false -> cleanMod?
  243.     ELSE                            \ All OK. Put info into import definition:
  244.         thisCfa >name c@  thisImp >name c!    \ Name flags
  245.         pos: $exp  thisImp 4+ w!        \ Export table index
  246.         thisCfa >nxtExp                    \ Add next exp tbl entry
  247.         ?!class: self                    \ More stuff if it's a class
  248.     THEN  ;m
  249.  
  250.  
  251. :mloc !EXPORTS:        \ { \ n thisImp thisCfa maddr -- }
  252.     get: #imp  0= ?error 143            \ Module has no exported names
  253.     clear: $exp
  254.     get: lastimp  set: theMark
  255.     get: #imp  FOR  1export: self  NEXT
  256. ;mloc
  257.  
  258. public
  259.  
  260. :m COMPILE:  { \ size newModbase -- }
  261.     compMod  ?error 177                    \ Error if already compiling a module
  262.     release: self                        \ Get rid of old version, if loaded
  263.     context 32  put: $cxt
  264.     dp -> svDP  latest -> svLatest  ^base -> compMod
  265.     get: loadpoint  (forget)  svDP -> dp
  266.     true -> cleanMod?
  267.     pushNew: loadFile
  268.     txtName: self  name: topFile
  269.     here -> modstart
  270.     modstart 32766 +  -> newModbase
  271.     16  reserve            \ Reserve space for header and offset to exports table.
  272.     ^base -> this_mod
  273.     newModbase LdFromMod
  274.     dateTime  modstart !                \ Put source date in bin module header
  275.     getDirID: topFile  modstart 4+ !    \ Also DirID of source file
  276.     drop: loadfile
  277.     0 -> this_mod
  278.     !exports: self
  279.     cleanMod?
  280.     IF            \ Everything's OK. Now we have some final housekeeping:
  281.  
  282.         here  modstart 8 +  displ!        \ Store export table offs in header
  283.         all: $exp  n,                    \ Add export table to end
  284.         here 4+ context -  ,            \ Adjustment value for context copy
  285.         context 32  n,                    \ Add copy of Context to end (so the
  286.                                         \  decompiler/debugger can find words)
  287.         here modstart -  -> size        \ Size of module
  288.         size  modstart 12 +  !            \ Store size in header
  289.         binName: self  name: fFcb        \ Set name of binary file
  290.         create: fFcb  ?error 139
  291.         'type BIN  'type MOPS  set: fFcb  \ Type and signature
  292.         modstart  size  write: fFcb        \ Write out binary module
  293.         close: fFcb  drop
  294.         IF
  295.             msg# 140                    \ I/O error on writing bin file
  296.         ELSE
  297.             curs  -curs
  298.             cr  getName: fFcb type  ."  saved"
  299.             -> curs
  300.         THEN
  301.     THEN
  302.     unmod                \ Also releases $cxt
  303.     release: $exp  ;m
  304.  
  305.  
  306. :m CLASSINIT:
  307.     -1  put: relOffs
  308.     dateTime put: dicDateTime  ;m
  309.  
  310. ;class
  311.  
  312.  
  313. : SETRELEASE    \ ( addr -- )
  314.     setRelease: this_mod  ;
  315.  
  316. : MLD
  317.     dup  load: **  ;
  318.  
  319. ' mld -> modLoad
  320.  
  321. : MOD?        \ ( cfa -- cfa b )
  322.     objCfa?  NIF  false  EXIT  THEN
  323.     dup >obj >classCfa  ['] module  =  ;
  324.  
  325.  
  326. : ?DISP  { theCfa size -- }        \ handler to release selected modules
  327.     theCfa mod?  NIF  drop  EXIT  THEN
  328.     free size <            \ Do we still need space?
  329.     IF    >obj  ?release: module
  330.     ELSE    drop
  331.     THEN  ;
  332.  
  333.  
  334. \ PURGE forcibly releases all modules, no matter what.  It is a vector,
  335. \ defined in file Base.
  336.  
  337. : (PRG)  { theCfa size -- }    \ unlock and release
  338.     theCfa mod? NIF  drop  EXIT  THEN
  339.     >obj release: module  ;
  340.  
  341. : (PURGE)    ['] (prg)  big#  trav  ;
  342.  
  343. ' (purge) -> purge
  344.  
  345.  
  346. : NEEDSPACE    \ ( #bytes -- ) release modules until #bytes are available
  347.     false -> released?
  348.     freeblk drop  ['] ?disp swap trav  ;
  349.  
  350. : GS    big# needSpace  released?  ;
  351.  
  352. ' gs -> getSpace
  353.  
  354.  
  355. : FROM        \ ( -- ^mod sec# )
  356.     module                            \ Create module object
  357.     latest name> >obj  dup -> last_mod  28  ;
  358.  
  359.  
  360. : IMPORT{    \ ( ^mod sec# -- )
  361.     28 ?pairs  getImports: **  ;
  362.  
  363. : EXPORTS_CLASS
  364.     last_mod  exports_class: **  ;
  365.  
  366.  
  367. \ Some imports, needed by what follows:
  368.  
  369. from PATHSMOD    import{  OWP  GETPATHS  .PATHS  }
  370. from CALL1&LMOD    import{  CallFirst  CallLast  (GET)  (C1)  (CL)  }
  371. from TOOL    import{  CALL ASMCALL FCALL GLOBAL $>GLOB KONST $>KONST  }
  372. from ASMMOD    import{  ASM :CODE :MCODE TOCODE  }
  373.  
  374.  
  375. :f OPEN_WITH_PATHS    OWP  ;f
  376.  
  377. compile: pathsMod
  378.  
  379. true -> use_paths?
  380. " mops.paths"  getPaths
  381.  
  382. ' (get) -> get1st&last
  383. ' (C1)  -> doCall1st
  384. ' (CL)  -> doCallLast
  385.  
  386. compile: call1&Lmod
  387.  
  388. endload
  389.  
  390. +echo
  391.  
  392. :class    HAHA    super{ int }
  393.  
  394. callLast    print:
  395.  
  396. :m BAtest:
  397.     1 2 3 . . .  ;m
  398. ;class
  399.  
  400. :class SUBHAHA  super{ haha }
  401.  
  402. callLast    dump:
  403.  
  404. :m BAtest:  -9 -8 -7 . . .  ;m
  405.  
  406. ;class
  407.  
  408. haha    hh
  409. subhaha    ss
  410.  
  411. : q db batest: hh  batest: ss  ;
  412.  
  413. endload
  414.  
  415.  
  416. : QQ    ." QQ here.  Hello. "  ;        \ This gets called from testMod
  417.  
  418. variable VB
  419.  
  420. from TESTMOD  import{ AA BB CC CLASSX DD }
  421. \ from TESTMOD2 import{ DD EE }
  422.  
  423.  
  424. : QQ    ." This is the wrong QQ!!!"  ;        \ This one shouldn't!
  425.  
  426. compile: testmod
  427. \ compile: testmod2
  428.